perm filename IO[NEW,LSP] blob
sn#484202 filedate 1980-08-21 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00006 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 Reads file.ext[p,pn] where .ext and [p,pn] are optional.
C00006 00003 Input
C00009 00004 Output.
C00013 00005 Scanner
C00017 00006 Scanner and Recovery
C00020 ENDMK
C⊗;
;;; Reads file.ext[p,pn] where .ext and [p,pn] are optional.
;;; Forms valid namelist
(declare (special ↑r ↑w ↑q lineno* pageno* linepagestack*))
(defun readfilename ()
(prog (file ext p pn line)
(setq line (exploden (readline tyi)))
start (cond ((null line) (go finish))
((= (car line) 32.) (setq line (cdr line)) (go start))
((= (car line) 46.) (go b))
((= (car line) 91.) (go c))
(t (setq file (cons (car line) file))
(setq line (cdr line))
(go start)))
b (setq line (cdr line))
(cond ((null line) (go finish))
((= (car line) 32.) (go b))
((= (car line) 91.) (go c))
(t (setq ext (cons (car line) ext)) (go b)))
c (setq line (cdr line))
(cond ((null line) (go finish))
((= (car line) 32.) (go c))
((= (car line) 44.) (go d))
(t (setq p (cons (car line) p)) (go c)))
d (setq line (cdr line))
(cond ((null line) (go finish))
((= (car line) 32.) (go d))
((= (car line) 93.) (go finish))
(t (setq pn (cons (car line) pn)) (go d)))
finish
(cond (file (setq file (maknam (nreverse file))))
(t (return nil)))
(setq ext (cond (ext (maknam (nreverse ext)))
(t '|←←←|)))
(setq p (cond (p (maknam (nreverse p)))
(t (car (status udir)))))
(setq pn (cond (pn (maknam (nreverse pn)))
(t (cadr (status udir)))))
(return (list (list 'dsk (list p pn)) file ext))))
;;; Writefilename takes a file pointer and princ's out its file.ext[p,pn] equivalent.
(defun writefilename (file)
(cond ((get 'eopen 'lsubr) ;;; Are we at SAIL?
(setq file (namelist file))
(princ (cadr file))
(cond ((eq (caddr file) '|←←←|))
(t (princ '|.|)
(princ (caddr file))))
(princ '|[|)
(princ (caadar file))
(princ '|,|)
(princ (cadr (cadar file)))
(princ '|]|))
(t (princ (namestring file)))))
;;; Input
;;; Char value meaning
;;; ↑Q nil input from terminal
;;; ↑Q t input from disk file
;;; Openread* (FILE) opens FILE; if another file is presently being read from,
;;; it is stacked until FILE reaches end of file when it is automatically unstacked.
(progn (setq pageno* 2)
(setq lineno* 1)
(setq linepagestack* nil))
(defun openread* (file)
(setq file (namelist file))
(cond ((null (probef file))
(princ-start '|File doesn't exist: |)
(writefilename file)
(princ-terpri '|.|)
(princ-terpri '|Command ignored.|))
((or (equal file (namelist infile))
(member file (mapcar 'namelist instack))
(member file (mapcar 'namelist outfiles)))
(princ-start '|File already open: |)
(writefilename file)
(princ-terpri '|.|)
(princ-terpri '|Command ignored.|))
(t (princ-start '|Reading from file |)
(writefilename file)
(princ-terpri '|.|)
(setq file (cond ((get 'eopen 'lsubr) ;;; Are we at SAIL?
(eopen file '(ascii in)))
(t (open file '(ascii in)))))
(inpush file)
(setq linepagestack* (cons (cons lineno* pageno*) linepagestack*))
(setq pageno* 2)
(setq lineno* 1)
(setq ↑q t)))
file)
(eoffn nil 'defaultcloseread*)
(defun defaultcloseread* (file x) (closeread*))
(defun closeread* ()
(princ-start '|Closing file |)
(writefilename infile)
(princ-terpri '|.|)
(close infile)
(setq lineno* (caar linepagestack*))
(setq pageno* (cdar linepagestack*))
(setq linepagestack* (cdr linepagestack*))
(inpush -1)
(cond (↑q
(princ '|Returning to file |)
(writefilename infile)
(princ-terpri '|.|)
(setq ↑q t))
(t (prompt))))
;;; Output.
;;; ↑R nil output does not include disk file
;;; ↑R t output does include disk file
;;; ↑W nil output does include the terminal
;;; ↑W t output does not include the terminal
;;; openwrite*(FILE SWITCH) adds FILE to the files presently being written
;;; on. If SWITCH is non-nil, a copy of the output also goes to the terminal.
;;; Note that unlike openread, openwrite does not stack filenames.
;;; Closewrite*() closes the most recently opened file. Closewritefile*(FILE)
;;; closes FILE.
(defun openwrite* (file copy)
(setq file (namelist file))
(cond ((or (equal file (namelist infile))
(member file (mapcar 'namelist instack))
(member file (mapcar 'namelist outfiles)))
(princ-start '|File already open: |)
(writefilename file)
(princ-terpri '|.|)
(princ-terpri '|Command ignored.|))
(t (and outfiles
(princ-start-terpri '|You are now writing to more than one file.|))
(cond ((probef file)
(deletef file)
(princ-start '|Deleting existing file: |))
(t (princ-start '|Opening file |)))
(writefilename file)
(princ-terpri '|.|)
(setq file (cond ((get 'eopen 'lsubr) ;;; Are we at SAIL?
(eopen file '(ascii out)))
(t (open file '(ascii out)))))
(cond (outfiles nil)
(copy (setq ↑w nil))
(t (setq ↑w t)))
(setq outfiles (cons file outfiles))
(setq ↑r t)))
file)
(defun closewrite* ()
(cond ((null outfiles)
(princ-start-terpri '|No output file open; command ignored.|))
(t (prog (file)
(setq file (car outfiles))
(close file)
(setq outfiles (cdr outfiles))
(cond ((null outfiles) (setq ↑r nil) (setq ↑w nil)))
(princ-start '|Closing file |)
(writefilename (namelist file))
(cond (outfiles (princ-terpri '|; other files still open.|))
(t (princ-terpri '|.|))))))
t)
(defun closewritefile* (file)
(cond ((not (memq file (mapcar 'namelist outfiles)))
(princ '|File |)
(writefilename file)
(princ-terpri '| not open.|))
((null (delq file outfiles))
(setq ↑r nil)
(setq ↑w nil))))
;;; Scanner
(declare (special readtable* scnval stringflag*))
(defsmac scanprint (x)
(cond ((memq x '(/( /) /,)) (princ x))
((memq x '(/; alias read write close copy)) (princ x) (princ '| |))
((get x 'pterminal) (princ '| |) (princ x) (princ '| |))
(t (princ x))))
(defsmac scancopy (x)
(cond ((and ↑q (not (> (charpos t) 50.)))
(scanprint x)
(and (> (charpos t) 50.) (princ '| ...|)))
(↑r ((lambda (↑w) (scanprint x)) t))))
(setq readtable* (array nil readtable))
(setq stringflag* nil)
(defun initlex* nil
((lambda (readtable delims lets)
(mapc (function (lambda (x) (setsyntax x 196608. x))) delims)
(mapc (function (lambda (x) (setsyntax x 2 x))) lets)
(do ((i 65. (1+ i))) ((= i 90.)) (setsyntax (+ i 32.) nil i))
(setsyntax 35. 1. 35.) ;;; # now a letter
(setsyntax 37. 'splicing 'comment*)
(setsyntax 123. 'splicing 'comment*)
(setsyntax 34. 'macro 'string*)
(setsyntax 10. 'splicing 'lfct*)
(setsyntax 12. 'splicing 'ffct*) )
readtable*
'(1. 2. 3. 4. 5. 6. 7. 8. 14. 15. 16. 17. 18. 19. 20.
21. 22. 23. 25. 26. 27. 28. 29. 30. 31. 33.
36. 38. 39. 40. 41. 42. 43. 44. 45. 46. 47.
58. 59. 60. 61. 62. 63. 64. 91. 92. 93. 94. 95. 96.
124. 125. 127.)
'(24.)))
(defun scan ()
((lambda (readtable readtable*)
((lambda (lexeme)
(scancopy lexeme)
(setq scnval lexeme)
(cond ((numberp lexeme) 2)
(stringflag* (setq stringflag* nil) 3)
((get lexeme 'pterminal))
(t 4)))
(read)))
readtable* readtable))
(defun string* nil
(do ((char (readch) (readch)) (r nil (cons char r)))
((eq char '/") (setq stringflag* t) (implode (nreverse r)))
(cond ((eq char (ascii 10.)) (lfct*))
((eq char (ascii 12.)) (ffct*)))))
;;; Scanner and Recovery
(defun comment* nil
(do ((char (readch) (readch)))
((memq char '(/% /})) nil)
(cond ((eq char (ascii 10.)) (lfct*))
((eq char (ascii 12.)) (ffct*)))))
(defun lfct* () (and ↑q (setq lineno* (1+ lineno*))) nil)
(defun ffct* nil
(cond (↑q (setq pageno* (1+ pageno*))
(setq lineno* 1.)))
nil)
(defun flush-sos-line-numbers* ()
(do ((char (tyipeek)(tyipeek)))
((not (member char '(10. 12. 13.))))
(tyi))
(do ((char (tyipeek)(tyipeek)))
((or (< char 48.)
(< 57. char)))
(tyi)))
(defun recover-parse ()
(setq errlist (list '(terpri)
(list 'setq 'errlist nil)
'(prompt)
'(parse)))
(↑g))
(defun recover-lisp ()
(setq errlist (list '(terpri)
(list 'setq 'errlist nil)))
(↑g))
(defun closefiles* ()
(cond ((eq infile t))
(t (close infile)
(mapcone (or (eq x t) (close x)) instack)
(inpush (- (length instack)))))
(mapc 'close outfiles)
(setq outfiles nil)
(setq pageno* 2)
(setq lineno* 1)
(setq linepagestack* nil)
(setq ↑w nil)
(setq ↑r nil))